/*
 * fParseWord -> fCompileWord; fExecuteMem <- fExecuteWord <- fMemRead
 *
 * PREDEFINED WORDS
 * system:
 *   return if if-true if-false cond loop do-times recur return tail-recur def set!
 *   defn fn exec alloc free here
 * logic:
 *   and or xor not
 * bitwise:
 *   b-and b-or b-xor b-not
 * arythmetic:
 *   + - * / % pow sqrt log ln log10 exp to-int to-float round ceil floor
 *
 * SPECIAL FORMS
 *  { a ... } == \a def ...  -- define local variables (macro)
 *  \name -- symbol (address in the dict?) (macro)
 *  &name -- bind local var. the same as {name}
 *  :name -- keyword (for future implementation) (macro)
 *  "..." -- string (macro)
 *  ( ... ) -- visual separator and block protector
 *             only the top stack value is returned.
 *
 * VM COMPONENTS
 * dictionary
 * memory
 * data stack
 * return stack
 * 
 * Dictionary: id, name, type, memory pointer
 * Memory: data
 *
 * SUBBLOCK COMPILATION:
 * 1. found '[';
 * 2. put the block starting words:
 * 2.1. current memory address;
 * 2.2. save dictionary position (for local definitions) (?)
 * 3. compile words;
 * 4. found ']';
 * 5. change the offset to skip the code by the block starter
 * 6. restore dictionary position
 *
 * Block starter -- special instruction to process code blocks
 * at compilation:
 *   1. save dictionary position
 * at execution:
 *   1. push the cude starting address to the stack;
 *   2. skip the code to the block-ender 
 */

#include <stdio.h>
#include <string.h>
#include <strings.h>
#include <stdint.h>
#include <errno.h>
#include <assert.h>
#include <math.h>
#include <unistd.h>
#include <stdlib.h>
#include <stdarg.h>

#include <readline/readline.h>
#include <readline/history.h>

#define F_MEMORY_SIZE 1024
#define F_STACK_SIZE 1024
#define F_RETSTACK_SIZE 1024
#define F_DICTIONARY_SIZE 1024
#define F_NAME_LENGTH 1024
#define F_BLOCKS_DEPTH 1024
#define F_NULL 0
#define F_TRUE 1
#define F_FALSE 0

/* Size constants for printf */
#if __WORDSIZE == 64
 #define F_UINT8  "%u"
 #define F_UINT32 "%u"
 #define F_UINT16 "%hu"
 #define F_UINT64 "%lu"
 #define F_INT8   "%d"
 #define F_INT16  "%hd"
 #define F_INT32  "%d"
 #define F_INT64  "%ld"
 #define F_HEX64  "%lx"
#else
 #define F_UINT8  "%u"
 #define F_UINT16 "%hu"
 #define F_UINT32 "%u"
 #define F_UINT64 "%llu"
 #define F_INT8   "%d"
 #define F_INT16  "%hd"
 #define F_INT32  "%d"
 #define F_INT64  "%lld"
 #define F_HEX64  "%llx"
#endif

/* TODO: get rid of these macros */
#define F_MEM_GET(fSys, target, pointer, type)  {memcpy(&(target), &fSys->memory[pointer + 1], sizeof(type)); pointer += sizeof(type);}
#define F_MEM_PUT(fSys, header, data) fMemPutData(fSys, header, (void*)data, sizeof(data))

#define F_RC_CHECK(op) if((op) != F_RC_OK) return F_RC_ERROR;

/*********************************************************************************/
/* Data types */
/* :types {{{ */

struct FSystem_st; /* future decl. */

typedef int       RetCode;
#define F_RC_OK     0
#define F_RC_ERROR  1
#define F_RC_STOP   2
#define F_RC_SKIP   3

typedef int64_t   FOffset;
typedef uint64_t  FIndex;
typedef uint8_t   FBool;
typedef int64_t   FInt;
typedef double    FFloat;
typedef uint32_t  FId;

typedef RetCode (*FNative) (struct FSystem_st *fSys);

/* Type of a word readed */
typedef enum
{
   F_WORD_UNDEFINED,
   F_WORD_SYMBOL,
   F_WORD_QUOTED,
   F_WORD_NUMBER,
   F_WORD_STRING
} FWordType;

/* Type of a memory cell */
typedef enum
{
   F_MEM_UNDEFINED,     /* 0 */
   F_MEM_MARKER,        /* FId */
   F_MEM_BLOCK,         /* FIndex */
   F_MEM_RETURN,        /* void */
   F_MEM_EXEC,
   F_MEM_STOP,          /* void */

   F_MEM_BOOL,          /* FBool */
   F_MEM_INT,           /* FInt */
   F_MEM_FLOAT,         /* FFloat */

   F_MEM_SYMBOL,        /* FIndex */ /* symbol id defined in the dictionary */
   F_MEM_VALUE,         /* FIndex */ /* value of a variable in the dictionary, dictionary offset */
   F_MEM_CALL,          /* FIndex */ /* call of a block */
   F_MEM_NATIVE,        /* FIndex */

   F_MEM_DEF,           /* define a local variable */
   F_MEM_DEFN           /* define a callable name */
} FMemType;

typedef union
{
   FIndex     fIndex;
   FOffset    fOffset;
   FBool      fBool;
   FInt       fInt;
   FFloat     fFloat;
   FId        fId;
   FNative    fNative;
} FValue;

/*
typedef struct
{
   FMemType type;
   FValue value;
} FMemCell;
*/

typedef uint8_t FMemCell;

typedef struct
{
   FId      id;
   char     name[F_NAME_LENGTH];
   FMemType type;
   FValue   value;
   const char *info;
} FDictRecord;

typedef struct FSystem_st
{
   FMemCell    memory[F_MEMORY_SIZE];
   FDictRecord dictionary[F_DICTIONARY_SIZE];
   FValue      stack[F_STACK_SIZE];
   FIndex      retStack[F_RETSTACK_SIZE];

   FIndex      memoryTop;
   FIndex      dictionaryTop;
   FIndex      stackTop;
   FIndex      retStackTop;

   FIndex      execP;
} FSystem;

/* }}} */

/*********************************************************************************/
/* Future declarations */
/* :future {{{ */

FOffset fMemRead(FSystem *fSys, FIndex ptr, FValue *value, FMemType *type);
FMemType fMemGetType(FSystem *fSys, FIndex ptr);

/* }}} */

/*********************************************************************************/
/* Log and Debug */
/* :log :dbg :trace {{{ */

void fLogOut(const char *msg, ...)
{
   va_list args;
   va_start(args, msg);
   vfprintf(stdout, msg, args);
   va_end(args);
}

void fLogErr(const char *msg, ...)
{
   va_list args;
   va_start(args, msg);
   fprintf(stderr, "!!> ");
   vfprintf(stderr, msg, args);
   fprintf(stderr, "\n");
   va_end(args);
}

void fTraceDict(FSystem *fSys)
{
   FIndex dictP;
   for (dictP = F_NULL; dictP <= fSys->dictionaryTop; dictP ++)
   {
      fLogOut("{" F_UINT64 ", \"%s\", " F_INT32 ", " F_UINT64 ", \"%s\"}\n",
            (uint64_t) fSys->dictionary[dictP].id,
            fSys->dictionary[dictP].name,
            fSys->dictionary[dictP].type,
            (uint64_t) fSys->dictionary[dictP].value.fIndex,
            fSys->dictionary[dictP].info);
   }
}

void fTraceMem(FSystem *fSys)
{
   FIndex memP;
   FValue value = {0};
   
   for (memP = F_NULL; memP < fSys->memoryTop; memP ++)
   {
      fLogOut("%08llu: ", (long long unsigned)memP);
      switch (fSys->memory[memP])
      {
         case F_MEM_UNDEFINED:
            fLogOut("F_MEM_UNDEFINED\n");
            break;
         case F_MEM_MARKER:
            fLogOut("F_MEM_MARKER\n");
            break;
         case F_MEM_BLOCK:
            F_MEM_GET(fSys, value.fIndex, memP, FIndex);
            fLogOut("F_MEM_BLOCK, " F_UINT64 "\n", value.fIndex);
            break;
         case F_MEM_RETURN:
            puts("F_MEM_RETURN");
            break;
         case F_MEM_EXEC:
            puts("F_MEM_EXEC");
            break;
         case F_MEM_STOP:
            puts("F_MEM_STOP");
            break;
         case F_MEM_BOOL:
            F_MEM_GET(fSys, value.fBool, memP, FBool);
            fLogOut("F_MEM_BOOL, %u\n", value.fBool);
         case F_MEM_INT:
            F_MEM_GET(fSys, value.fInt, memP, FInt);
            fLogOut("F_MEM_INT, " F_INT64 "\n", value.fInt);
            break;
         case F_MEM_FLOAT:
            F_MEM_GET(fSys, value.fFloat, memP, FFloat);
            fLogOut("F_MEM_FLOAT, %lf\n", value.fFloat);
            break;
         case F_MEM_SYMBOL:
            F_MEM_GET(fSys, value.fIndex, memP, FIndex);
            fLogOut("F_MEM_SYMBOL, " F_UINT64 "\n", value.fIndex);
            break;
         case F_MEM_CALL:
            F_MEM_GET(fSys, value.fIndex, memP, FIndex);
            fLogOut("F_MEM_CALL, " F_UINT64 "\n", value.fIndex);
            break;
         case F_MEM_VALUE:
            F_MEM_GET(fSys, value.fIndex, memP, FIndex);
            fLogOut("F_MEM_VALUE, " F_UINT64, "\n", value.fIndex);
            break;
         case F_MEM_NATIVE:
            F_MEM_GET(fSys, value.fIndex, memP, FNative);
            fLogOut("F_MEM_NATIVE, %p\n", value.fNative);
            break;
         default:
            fLogOut("ERRONEOUS!, ");
      }
   }
}

void fTraceStack(FSystem *fSys)
{
   uint32_t i = 0;

   fLogOut("STACK (" F_UINT64 "):\n", fSys->stackTop);

   for (i = 0; i < fSys->stackTop; i ++)
   {
      fLogOut("% 2d. %lld\n", i, (long long int)fSys->stack[i].fIndex);
   } 
}

void fTraceRetStack(FSystem *fSys)
{
   FIndex i = 0;

   fLogOut("RET_STACK (" F_UINT64 "):\n", fSys->retStackTop);

   for (i = 0; i < fSys->retStackTop; i ++)
      fLogOut("%lld\n", (long long int)fSys->retStack[i]);
}

/* }}} */

/*********************************************************************************/
/* Stack procedures */
/* :stack {{{ */

FValue* fStackTop(FSystem *fSys)
{
   if (fSys->stackTop <= 0)
   {
      errno = ENOENT;
      return NULL;
   }

   return &fSys->stack[fSys->stackTop - 1];
}

FValue* fStackNth(FSystem *fSys, size_t n)
{
   if (fSys->stackTop <= n)
   {
      errno = ENOENT;
      return NULL;
   }

   return &fSys->stack[fSys->stackTop - n - 1];
}

RetCode fStackPush(FSystem *fSys, FValue value)
{
   if (fSys->stackTop >= F_STACK_SIZE)
   {
      errno = E2BIG;
      return F_RC_ERROR;
   }

   fSys->stack[fSys->stackTop] = value;
   fSys->stackTop ++;
   return F_RC_OK;
}

RetCode fStackPop(FSystem *fSys, FValue *value)
{
   if (fSys->stackTop == 0)
   {
      errno = ENOENT;
      return F_RC_ERROR;
   }
   if (value == NULL)
   {
      errno = EINVAL;
      return F_RC_ERROR;
   }

   fSys->stackTop --;
   *value = fSys->stack[fSys->stackTop];
   return F_RC_OK;
}

FIndex fStackDepth(FSystem *fSys)
{
   return fSys->stackTop;
}

RetCode fStackDrop(FSystem *fSys)
{
   if (fSys->stackTop == 0)
      return F_RC_ERROR;
   
   fSys->stackTop --;
   return F_RC_OK;
}

RetCode fRetPush(FSystem *fSys, FIndex address)
{
   if (fSys->retStackTop + 1 >= F_RETSTACK_SIZE)
   {
      fLogErr("Return stack is full");
      return F_RC_ERROR;
   }

   fSys->retStack[fSys->retStackTop ++] = address;
   return F_RC_OK;
}

RetCode fRetPop(FSystem *fSys, FIndex *address)
{
   if (fSys->retStackTop == 0)
   {
      fLogErr("Return stack is empty");
      return F_RC_ERROR;
   }

   *address = fSys->retStack[-- fSys->retStackTop];
   return F_RC_OK;
}

FIndex* fRetTop(FSystem *fSys)
{
   if (fSys->retStackTop == 0)
   {
      errno = ENOENT;
      return NULL;
   }

   return &fSys->retStack[fSys->retStackTop - 1];
}

FIndex* fRetNth(FSystem *fSys, FIndex n)
{
   if (fSys->retStackTop == 0 || n >= fSys->retStackTop)
   {
      errno = ENOENT;
      return NULL;
   }

   return &fSys->retStack[fSys->retStackTop - 1 - n];
}

RetCode fRetDrop(FSystem *fSys)
{
   if (fSys->retStackTop == 0)
   {
      errno = ENOENT;
      return F_RC_ERROR;
   }
   
   fSys->retStackTop --;
   return F_RC_OK;
}

/* execute block by address addr with return point ret */
RetCode fExecuteBlockRet(FSystem *fSys, FIndex addr, FIndex ret)
{
   /* check the given address contains block */
   if (fMemGetType(fSys, addr) != F_MEM_BLOCK)
   {
      fLogErr("execute-block: the given address does not contain a block");
      return F_RC_ERROR;
   }

   if (ret > fSys->memoryTop)
   {
      fLogErr("execute-block: return position is incorrect");
      return F_RC_ERROR;
   }

   /* push values to ret.stack */
   F_RC_CHECK( fRetPush(fSys, ret) ); /* return address */
   F_RC_CHECK( fRetPush(fSys, fSys->dictionaryTop) );
   F_RC_CHECK( fRetPush(fSys, addr) ); /* push self address for recursive calls */

   fSys->execP = addr + 1 + sizeof(FIndex) / sizeof(FMemCell);

   return F_RC_OK;
}
RetCode fExecuteBlock(FSystem *fSys, FIndex addr)
{
   return fExecuteBlockRet(fSys, addr, fSys->execP);
}

/* }}} */

/*********************************************************************************/
/* Native Functions */
/* :native {{{ */

/*=== system ===*/

RetCode fNativeDef(FSystem *fSys)
{
   FValue val;
   FId    id;     /* symbol id */

   /* get the symbol to define */
   F_RC_CHECK( fStackPop(fSys, &val) );
   FIndex id = val.fId;

   /* get the value */
   F_RC_CHECK( fStackPop(fSys, &val) );

   fSymRegister(fSys, id, F_NULL);

   return F_RC_OK;
}

RetCode fNativeHere(FSystem *fSys)
{
   FValue val;
   val.fIndex = fSys->execP;
   return fStackPush(fSys, val);
}

RetCode fNativeDup(FSystem *fSys)
{
   FValue *val = fStackTop(fSys);
   if (val == NULL)
   {
      fLogErr("dup: the stack is empty");
      return F_RC_ERROR;
   }

   return fStackPush(fSys, *val);
}

RetCode fNativeDrop(FSystem *fSys)
{
   return fStackDrop(fSys);
}

RetCode fNativeSwap(FSystem *fSys)
{
   FValue v;
   FValue *p1, *p2;

   p1 = fStackNth(fSys, 0);
   p2 = fStackNth(fSys, 1);

   if (p1 == NULL || p2 == NULL)
   {
      fLogErr("swap: no enough values");
      return F_RC_ERROR;
   }

   v = *p1;
   *p1 = *p2;
   *p2 = v;
   return F_RC_OK;
}

RetCode fNativeRot(FSystem *fSys)
{
   FValue a, b, c;

   if (fSys->stackTop < 3)
   {
      errno = ENOENT;
      return F_RC_ERROR;
   }

   F_RC_CHECK( fStackPop(fSys, &c) );
   F_RC_CHECK( fStackPop(fSys, &b) );
   F_RC_CHECK( fStackPop(fSys, &a) );

   F_RC_CHECK( fStackPush(fSys, b) );
   F_RC_CHECK( fStackPush(fSys, c) );
   F_RC_CHECK( fStackPush(fSys, a) );

   return F_RC_OK;
}

RetCode fNativeClear(FSystem *fSys)
{
   fSys->stackTop = 0;
   return F_RC_OK;
}

/*=== arythmetic ===*/

RetCode fNativeAdd(FSystem *fSys)
{
   FValue *val0;
   FValue  val1;
   RetCode rc = F_RC_OK;

   rc = fStackPop(fSys, &val1);
   if (rc != F_RC_OK)
   {
      fLogErr("+: no enough values");
      return F_RC_ERROR;
   }

   val0 = fStackTop(fSys);
   if (val0 == NULL)
   {
      fLogErr("+: no enough values");
      return F_RC_ERROR;
   }

   val0->fInt += val1.fInt;
   return F_RC_OK;
}

RetCode fNativeFAdd(FSystem *fSys)
{
   FValue *val0;
   FValue  val1;
   RetCode rc = F_RC_OK;

   rc = fStackPop(fSys, &val1);
   if (rc != F_RC_OK)
      return F_RC_ERROR;

   val0 = fStackTop(fSys);
   if (val0 == NULL)
      return F_RC_ERROR;

   val0->fFloat += val1.fFloat;
   return F_RC_OK;
}

RetCode fNativeSub(FSystem *fSys)
{
   FValue *val0;
   FValue  val1;
   RetCode rc = F_RC_OK;

   rc = fStackPop(fSys, &val1);
   if (rc != F_RC_OK)
      return F_RC_ERROR;

   val0 = fStackTop(fSys);
   if (val0 == NULL)
      return F_RC_ERROR;

   val0->fInt -= val1.fInt;
   return F_RC_OK;
}

RetCode fNativeFSub(FSystem *fSys)
{
   FValue *val0;
   FValue  val1;
   RetCode rc = F_RC_OK;

   rc = fStackPop(fSys, &val1);
   if (rc != F_RC_OK)
      return F_RC_ERROR;

   val0 = fStackTop(fSys);
   if (val0 == NULL)
      return F_RC_ERROR;

   val0->fFloat -= val1.fFloat;
   return F_RC_OK;
}

RetCode fNativeMul(FSystem *fSys)
{
   FValue *val0;
   FValue  val1;
   RetCode rc = F_RC_OK;

   rc = fStackPop(fSys, &val1);
   if (rc != F_RC_OK)
      return F_RC_ERROR;

   val0 = fStackTop(fSys);
   if (val0 == NULL)
      return F_RC_ERROR;

   val0->fInt *= val1.fInt;
   return F_RC_OK;
}

RetCode fNativeFMul(FSystem *fSys)
{
   FValue *val0;
   FValue  val1;
   RetCode rc = F_RC_OK;

   rc = fStackPop(fSys, &val1);
   if (rc != F_RC_OK)
      return F_RC_ERROR;

   val0 = fStackTop(fSys);
   if (val0 == NULL)
      return F_RC_ERROR;

   val0->fFloat *= val1.fFloat;
   return F_RC_OK;
}

RetCode fNativeDiv(FSystem *fSys)
{
   FValue *val0;
   FValue  val1;
   RetCode rc = F_RC_OK;

   rc = fStackPop(fSys, &val1);
   if (rc != F_RC_OK)
      return F_RC_ERROR;

   if (val1.fInt == 0)
   {
      errno = EINVAL;
      return F_RC_ERROR;
   }

   val0 = fStackTop(fSys);
   if (val0 == NULL)
      return F_RC_ERROR;

   val0->fInt /= val1.fInt;
   return F_RC_OK;
}

RetCode fNativeFDiv(FSystem *fSys)
{
   FValue *val0;
   FValue  val1;
   RetCode rc = F_RC_OK;

   rc = fStackPop(fSys, &val1);
   if (rc != F_RC_OK)
      return F_RC_ERROR;

   if (val1.fFloat == 0.0)
   {
      errno = EINVAL;
      return F_RC_ERROR;
   }

   val0 = fStackTop(fSys);
   if (val0 == NULL)
      return F_RC_ERROR;

   val0->fFloat /= val1.fFloat;
   return F_RC_OK;
}

/*=== output ===*/

RetCode fNativePrint(FSystem *fSys)
{
   RetCode rc = F_RC_OK;
   FValue value;

   rc = fStackPop(fSys, &value);
   if (rc != F_RC_OK)
      return F_RC_ERROR;

   fLogOut(F_INT64 "\n", value.fInt);

   return rc;
}

RetCode fNativeFPrint(FSystem *fSys)
{
   RetCode rc = F_RC_OK;
   FValue value;

   rc = fStackPop(fSys, &value);
   if (rc != F_RC_OK)
      return F_RC_ERROR;

   fLogOut("%f\n", value.fFloat);

   return rc;
}

/*=== debug === */

RetCode fNativePrintStack(FSystem *fSys)
{
   fTraceStack(fSys);
   return F_RC_OK;
}

RetCode fNativePrintRetStack(FSystem *fSys)
{
   fTraceRetStack(fSys);
   return F_RC_OK;
}

RetCode fNativePrintMem(FSystem *fSys)
{
   fTraceMem(fSys);
   return F_RC_OK;
}

RetCode fNativePrintDict(FSystem *fSys)
{
   fTraceDict(fSys);
   return F_RC_OK;
}

/*=== convert ===*/

RetCode fNativeIToF(FSystem *fSys)
{
   FValue *val = fStackTop(fSys);
   if (val == NULL)
      return F_RC_ERROR;

   FInt v = val->fInt;
   val->fFloat = (FFloat) v;
   return F_RC_OK;
}

RetCode fNativeFToI(FSystem *fSys)
{
   FValue *val = fStackTop(fSys);
   if (val == NULL)
      return F_RC_ERROR;

   FFloat v = val->fFloat;
   val->fInt = (FInt) v;
   return F_RC_OK;
}

/*=== trigonometry ===*/

RetCode fNativeSin(FSystem *fSys)
{
   FValue *p = fStackTop(fSys);
   if (p == NULL)
      return F_RC_ERROR;

   p->fFloat = sin(p->fFloat);
   return F_RC_OK;
}

RetCode fNativeCos(FSystem *fSys)
{
   FValue *p = fStackTop(fSys);
   if (p == NULL)
      return F_RC_ERROR;

   p->fFloat = cos(p->fFloat);
   return F_RC_OK;
}

RetCode fNativePi(FSystem *fSys)
{
   FValue v;
   v.fFloat = M_PI;
   return fStackPush(fSys, v);
}

/*=== comparison ===*/

RetCode fNativeLT(FSystem *fSys)
{
   FValue a;
   FValue b;
   FValue v;

   if (fStackPop(fSys, &b) != F_RC_OK ||
       fStackPop(fSys, &a) != F_RC_OK)
   {
      fLogErr("< no enough values");
      return F_RC_ERROR;
   }

   v.fInt = (a.fInt < b.fInt);
   F_RC_CHECK( fStackPush(fSys, v) );

   return F_RC_OK;
}

RetCode fNativeGT(FSystem *fSys)
{
   FValue a;
   FValue b;
   FValue v;

   if (fStackPop(fSys, &b) != F_RC_OK ||
       fStackPop(fSys, &a) != F_RC_OK)
   {
      fLogErr("< no enough values");
      return F_RC_ERROR;
   }

   v.fInt = (a.fInt > b.fInt);
   F_RC_CHECK( fStackPush(fSys, v) );

   return F_RC_OK;
}

RetCode fNativeLE(FSystem *fSys)
{
   FValue a;
   FValue b;
   FValue v;

   if (fStackPop(fSys, &b) != F_RC_OK ||
       fStackPop(fSys, &a) != F_RC_OK)
   {
      fLogErr("< no enough values");
      return F_RC_ERROR;
   }

   v.fInt = (a.fInt <= b.fInt);
   F_RC_CHECK( fStackPush(fSys, v) );

   return F_RC_OK;
}

RetCode fNativeGE(FSystem *fSys)
{
   FValue a;
   FValue b;
   FValue v;

   if (fStackPop(fSys, &b) != F_RC_OK ||
       fStackPop(fSys, &a) != F_RC_OK)
   {
      fLogErr("<: no enough values");
      return F_RC_ERROR;
   }

   v.fInt = (a.fInt >= b.fInt);
   F_RC_CHECK( fStackPush(fSys, v) );

   return F_RC_OK;
}

RetCode fNativeInRange(FSystem *fSys)
{
   FValue ret = {0};
   FValue x, a, b;

   if (fStackPop(fSys, &b) != F_RC_OK ||
       fStackPop(fSys, &a) != F_RC_OK ||
       fStackPop(fSys, &x) != F_RC_OK)
   {
      fLogErr("in-range: no enough values");
      return F_RC_ERROR;
   }

   ret.fInt = (x.fInt >= a.fInt && x.fInt <= b.fInt);
   F_RC_CHECK( fStackPush(fSys, ret) );
    
   return F_RC_OK;
}

RetCode fNativeFloatLT(FSystem *fSys)
{
   FValue a;
   FValue b;
   FValue v;

   if (fStackPop(fSys, &b) != F_RC_OK ||
       fStackPop(fSys, &a) != F_RC_OK)
   {
      fLogErr("< no enough values");
      return F_RC_ERROR;
   }

   v.fInt = (a.fFloat < b.fFloat);
   F_RC_CHECK( fStackPush(fSys, v) );

   return F_RC_OK;
}

RetCode fNativeFloatGT(FSystem *fSys)
{
   FValue a;
   FValue b;
   FValue v;

   if (fStackPop(fSys, &b) != F_RC_OK ||
       fStackPop(fSys, &a) != F_RC_OK)
   {
      fLogErr("< no enough values");
      return F_RC_ERROR;
   }

   v.fInt = (a.fFloat > b.fFloat);
   F_RC_CHECK( fStackPush(fSys, v) );

   return F_RC_OK;
}

RetCode fNativeFloatLE(FSystem *fSys)
{
   FValue a;
   FValue b;
   FValue v;

   if (fStackPop(fSys, &b) != F_RC_OK ||
       fStackPop(fSys, &a) != F_RC_OK)
   {
      fLogErr("< no enough values");
      return F_RC_ERROR;
   }

   v.fInt = (a.fFloat <= b.fFloat);
   F_RC_CHECK( fStackPush(fSys, v) );

   return F_RC_OK;
}

RetCode fNativeFloatGE(FSystem *fSys)
{
   FValue a;
   FValue b;
   FValue v;

   if (fStackPop(fSys, &b) != F_RC_OK ||
       fStackPop(fSys, &a) != F_RC_OK)
   {
      fLogErr("<: no enough values");
      return F_RC_ERROR;
   }

   v.fInt = (a.fFloat >= b.fFloat);
   F_RC_CHECK( fStackPush(fSys, v) );

   return F_RC_OK;
}

RetCode fNativeFloatInRange(FSystem *fSys)
{
   FValue ret = {0};
   FValue x, a, b;

   if (fStackPop(fSys, &b) != F_RC_OK ||
       fStackPop(fSys, &a) != F_RC_OK ||
       fStackPop(fSys, &x) != F_RC_OK)
   {
      fLogErr("in-range: no enough values");
      return F_RC_ERROR;
   }

   ret.fInt = (x.fInt >= a.fInt && x.fInt <= b.fInt);
   F_RC_CHECK( fStackPush(fSys, ret) );
    
   return F_RC_OK;
}


/*=== system ===*/

RetCode fNativeExit(FSystem *fSys)
{
   FValue v;
   if (fStackPop(fSys, &v) != F_RC_OK)
      v.fInt = -1;
   exit(v.fInt);
}

RetCode fNativeQuit(FSystem *fSys)
{
   exit(0);
}

/*=== control flow ===*/

RetCode fNativeIfTrue(FSystem *fSys)
{
   FValue cond;  /* condition */
   FValue block; /* block address */

   if (fStackPop(fSys, &block) != F_RC_OK || fStackPop(fSys, &cond) != F_RC_OK)
   {
      fLogErr("if-true: no enough values");
      return F_RC_ERROR;
   }

   if (cond.fInt != 0)
   {
      if (fExecuteBlock(fSys, block.fIndex) != F_RC_OK)
         return F_RC_ERROR;
      return F_RC_SKIP;
   }
   else
   {
      return F_RC_OK;
   }
}

RetCode fNativeIfFalse(FSystem *fSys)
{
   FValue cond;  /* condition */
   FValue block; /* block address */

   if (fStackPop(fSys, &block) != F_RC_OK || fStackPop(fSys, &cond) != F_RC_OK)
   {
      fLogErr("if-false: no enough values");
      return F_RC_ERROR;
   }

   if (cond.fInt == 0)
      return fExecuteBlock(fSys, block.fIndex);
   else
      return F_RC_OK;
}

RetCode fNativeIf(FSystem *fSys)
{
   FValue blockThen;
   FValue blockElse;
   FValue cond;

   if (fStackPop(fSys, &blockElse) != F_RC_OK ||
       fStackPop(fSys, &blockThen) != F_RC_OK ||
       fStackPop(fSys, &cond) != F_RC_OK)
   {
      fLogErr("if: no enough values");
      return F_RC_ERROR;
   }

   if (cond.fInt != 0)
      return fExecuteBlock(fSys, blockThen.fIndex);
   else
      return fExecuteBlock(fSys, blockElse.fIndex);
}

RetCode fNativeIfExec(FSystem *fSys)
{
   FValue cond;
   FValue   val;
   FMemType type;

   if(fStackPop(fSys, &cond) != F_RC_OK)
   {
      fLogErr("?: no condition given");
      return F_RC_ERROR;
   }

   /* read the following instruction */
   if (fMemRead(fSys, fSys->execP, &val, &type) == 0 ||
       type != F_MEM_BLOCK)
   {
      fLogErr("execute-block: cannot read block data");
      return F_RC_ERROR;
   }

   if (cond.fInt != 0)
      return fExecuteBlockRet(fSys, fSys->execP, val.fIndex);
   else
      fSys->execP = val.fIndex;
   
   return F_RC_OK;
}

RetCode fNativeDoTimes(FSystem *fSys)
{
   int i = 0;
   FValue times;
   FValue block;

   if (fStackPop(fSys, &block) != F_RC_OK ||
       fStackPop(fSys, &times) != F_RC_OK)
   {
      fLogErr("do-times: values expected");
      return F_RC_ERROR;
   }

   for (i = 0; i < times.fInt; i ++)
      F_RC_CHECK( fExecuteBlockRet(fSys, block.fIndex, fSys->execP) );

   return F_RC_OK;
}

RetCode fNativeRecur(FSystem *fSys)
{
   if (fSys->retStackTop < 2)
   {
      fLogErr("recur: cannot recur here");
      return F_RC_ERROR;
   }

   return fExecuteBlock(fSys, *(fRetTop(fSys)));
}

RetCode fNativeRecurLevel(FSystem *fSys)
{
   FValue level;
   FIndex *addr;

   F_RC_CHECK( fStackPop(fSys, &level) );

   if (fSys->retStackTop < (level.fInt + 1) * 3)
   {
      fLogErr("recur: cannot recur here");
      return F_RC_ERROR;
   }

   addr = fRetNth(fSys, level.fInt * 3);
   fLogOut("xrecur: run at %lu\n", *addr);

   return fExecuteBlock(fSys, *addr);
}

RetCode fNativeTailRecur(FSystem *fSys)
{
   FIndex addr;
   FIndex ret;

   if (fSys->retStackTop < 2)
   {
      fLogErr("tail-recur: cannot recur here");
      return F_RC_ERROR;
   }

   F_RC_CHECK( fRetPop(fSys, &addr) );
   F_RC_CHECK( fRetDrop(fSys) );
   F_RC_CHECK( fRetPop(fSys, &ret) );

   return fExecuteBlockRet(fSys, addr, ret);
}

RetCode fNativeTailXRecur(FSystem *fSys)
{
   FValue level;
   FIndex addr;
   FIndex ret;

   F_RC_CHECK( fStackPop(fSys, &level) );

   if (fSys->retStackTop < (level.fInt + 1) * 2)
   {
      fLogErr("xrecur: cannot recur here");
      return F_RC_ERROR;
   }

   fSys->retStackTop -= level.fInt * 2;

   F_RC_CHECK( fRetPop(fSys, &addr) );
   F_RC_CHECK( fRetDrop(fSys) );
   F_RC_CHECK( fRetPop(fSys, &ret) );

   return fExecuteBlockRet(fSys, addr, ret);
}

/*=== misc ===*/

RetCode fNativeStackProStart(FSystem *fSys)
{
   return fRetPush(fSys, fSys->stackTop);
}

RetCode fNativeStackProEnd(FSystem *fSys)
{
   /* TODO: this breaks [ x-recur ] */

   FIndex oldTop;
   FValue value;

   F_RC_CHECK( fRetPop(fSys, &oldTop) );

   if (fSys->stackTop <= oldTop)
   {
      fLogErr("(): a value expected");
      return F_RC_ERROR;
   }

   F_RC_CHECK( fStackPop(fSys, &value) );

   fSys->stackTop = oldTop;
   return fStackPush(fSys, value);
}

/* }}} */

/*********************************************************************************/
/* Dictionary Methods */
/* :dict {{{ */

/* unconditionally creates a new record in the dictionary */
FIndex fSymRegister(FSystem *fSys, FId id, char *name, FMemType type, FValue *value, const char *info)
{
   if (id == F_NULL && name == F_NULL)
   {
      errno = EINVAL;
      return F_NULL;
   }
   if (fSys->dictionaryTop >= F_DICTIONARY_SIZE)
   {
      errno = E2BIG;
      return F_NULL;
   }

   /* TODO: mutex_lock */
   fSys->dictionaryTop ++;
   FIndex dictP = fSys->dictionaryTop;
   /* TODO: mutex_unlock */

   fSys->dictionary[dictP].id = (id == F_NULL ? dictP : id);
   if (name != NULL)
      strncpy(fSys->dictionary[dictP].name, name, F_NAME_LENGTH - 1);
   else
      fSys->dictionary[dictP].name[0] = '\0';
   fSys->dictionary[dictP].type = type;
   if (value != NULL)
      fSys->dictionary[dictP].value = *value;
   else
      memset(&fSys->dictionary[dictP].value, 0, sizeof(FValue));

   /* documentation */
   fSys->dictionary[dictP].info = info;

   return dictP;
}

FIndex fSymGetByName(FSystem *fSys, char *word)
{
   FIndex dictP;
   for (dictP = fSys->dictionaryTop; dictP > 0; dictP --)
      if (strcmp(fSys->dictionary[dictP].name, word) == 0)
         return dictP;
   return F_NULL;
}

FIndex fSymGetById(FSystem *fSys, FId id)
{
   FIndex dictP;
   for (dictP = fSys->dictionaryTop; dictP > 0; dictP --)
      if (fSys->dictionary[dictP].id == id)
         return dictP;
   return F_NULL;
}

FIndex fSymLocate(FSystem *fSys, char *word)
{
   FIndex dictP = fSymGetByName(fSys, word);
   if (dictP == F_NULL)
      return fSymRegister(fSys, F_NULL, word, F_MEM_UNDEFINED, NULL, NULL);
   return dictP;
}

/* TODO: name must be a pointer in the structure */
FIndex fSymPush(FSystem *fSys, FId id, char *name, FMemType type, FValue value, const char *info)
{
   FIndex oldIdx = F_NULL;

   if (id == F_NULL && name == F_NULL)
   {
      errno = EINVAL;
      return F_NULL;
   }

   if (id != F_NULL)
      oldIdx = fSymGetById(fSys, id);
   else
      oldIdx = fSymGetByName(fSys, name);

   FIndex newIdx = fSymRegister(fSys, oldIdx, name, type, &value, info);
   return newIdx;
}

/* }}} */

/*********************************************************************************/
/* General procedures */
/* :sys {{{ */

void fRegisterNative(FSystem *fSys, char *name, FNative fn, const char *info)
{
   FValue val;
   val.fNative = fn;
   fSymPush(fSys, F_NULL, name, F_MEM_NATIVE, val, info);
}

void fInitNative(FSystem *fSys)
{
   fRegisterNative(fSys, "here",  fNativeHere,        "( -- p)  put current memory address on the stack");
   fRegisterNative(fSys, "dup",   fNativeDup,         NULL);
   fRegisterNative(fSys, "drop",  fNativeDrop, NULL);
   fRegisterNative(fSys, "swap",  fNativeSwap, NULL);
   fRegisterNative(fSys, "rot",   fNativeRot, NULL);
   fRegisterNative(fSys, "clear", fNativeClear, NULL);
   fRegisterNative(fSys, ".s",    fNativePrintStack, NULL);
   fRegisterNative(fSys, ".m",    fNativePrintMem, NULL);
   fRegisterNative(fSys, ".d",    fNativePrintDict, NULL);
   fRegisterNative(fSys, ".r",    fNativePrintRetStack, NULL);

   fRegisterNative(fSys, "add", fNativeAdd, "(n n -- n)  addition");
   fRegisterNative(fSys, "sub", fNativeSub, NULL);
   fRegisterNative(fSys, "mul", fNativeMul, NULL);
   fRegisterNative(fSys, "div", fNativeDiv, NULL);
   fRegisterNative(fSys, ".", fNativePrint, NULL);

   fRegisterNative(fSys, "+", fNativeFAdd, NULL);
   fRegisterNative(fSys, "-", fNativeFSub, NULL);
   fRegisterNative(fSys, "*", fNativeFMul, NULL);
   fRegisterNative(fSys, "/", fNativeFDiv, NULL);
   fRegisterNative(fSys, "f.", fNativeFPrint, NULL);

   fRegisterNative(fSys, "sin", fNativeSin, NULL);
   fRegisterNative(fSys, "cos", fNativeCos, NULL);
   fRegisterNative(fSys, "pi", fNativePi, NULL);

   fRegisterNative(fSys, "gt", fNativeGT, NULL);
   fRegisterNative(fSys, "lt", fNativeLT, NULL);
   fRegisterNative(fSys, "ge", fNativeGE, NULL);
   fRegisterNative(fSys, "le", fNativeLE, NULL);
   fRegisterNative(fSys, "in-int-range", fNativeInRange, NULL);

   fRegisterNative(fSys, ">", fNativeFloatGT, NULL);
   fRegisterNative(fSys, "<", fNativeFloatLT, NULL);
   fRegisterNative(fSys, ">=", fNativeFloatGE, NULL);
   fRegisterNative(fSys, "<=", fNativeFloatLE, NULL);
   fRegisterNative(fSys, "in-float-range", fNativeFloatInRange, NULL);

   fRegisterNative(fSys, "~f", fNativeIToF, NULL);
   fRegisterNative(fSys, "~i", fNativeFToI, NULL);

   fRegisterNative(fSys, "exit", fNativeExit, NULL);
   fRegisterNative(fSys, "quit", fNativeQuit, NULL);

   fRegisterNative(fSys, "if-true", fNativeIfTrue, NULL);
   fRegisterNative(fSys, "if-false", fNativeIfFalse, NULL);
   fRegisterNative(fSys, "if", fNativeIf, NULL);
   fRegisterNative(fSys, "?", fNativeIfExec, NULL);
   fRegisterNative(fSys, "do-times", fNativeDoTimes, NULL);
   fRegisterNative(fSys, "recur", fNativeRecur, NULL);
   fRegisterNative(fSys, "xrecur", fNativeRecurLevel, NULL);
   fRegisterNative(fSys, "tail-recur", fNativeTailRecur, NULL);
   fRegisterNative(fSys, "tail-xrecur", fNativeTailXRecur, NULL);

   fRegisterNative(fSys, "(", fNativeStackProStart, NULL);
   fRegisterNative(fSys, ")", fNativeStackProEnd, NULL);
}

void fInit(FSystem *fSys)
{
   fSys->memoryTop     = 0;
   fSys->dictionaryTop = 0;
   fSys->stackTop      = 0;
   fSys->retStackTop   = 0;

   fInitNative(fSys);
}

size_t fParseWord(const char *buf, char *word)
{
   char *wordP = word;
   char *p = (char*) buf;
   assert(p != NULL && wordP != NULL);

   /* skip leading empty characters */
   while (*p == ' ' || *p == '\t' || *p == '\n')
      p ++;

   /* special processing for a string */
   if (*p == '"')
   {
      int spec = 0;

      /* write the quote sign */
      *(wordP++) = *(p++);

      while (*p != '\0')
      {
         if (spec)
         {
            switch (*p)
            {
               case '\\':
                  *(wordP++) = '\\';
                  break;
               case 'n':
                  *(wordP++) = '\n';
                  break;
               case 't':
                  *(wordP++) = '\t';
                  break;
               case '"':
                  *(wordP++) = '"';
                  break;
               default:
                  *(wordP++) = '\\';
                  *(wordP++) = *p;
            }
            spec = 0;
         }

         else if (*p == '\\')
            spec = 1;

         else if (*p == '"')
         {
            *(wordP++) = *p;
            break;
         }

         else
            *(wordP++) = *p;

         p ++;
      }

      *wordP = '\0';

      if (word == wordP)
         return 0;
      else
         return p - buf + 1;
   }

   /* skipping out a comment */
   if (*p == ';')
   {
      while (*p != '\n' && *p != '\0')
         p ++;
   }

   /* special characters that cannot be a part of a word */
   if (*p != '\0' && index("[]{}()", *p) != NULL)
   {
      *(wordP++) = *p;
      *wordP = '\0';
      return p - buf + 1;
   }

   /* the symbol */
   while ( *p != ' ' && *p != '\t' && *p != '\n' && *p != '\0' &&
           index("[]{}()", *p) == NULL && (p - buf) < F_NAME_LENGTH )
   {
      *(wordP++) = *(p++);
   }

   *wordP = '\0';
   if (word == wordP)
      return 0;

   return (size_t) (p - buf);
}

RetCode fMemPut(FSystem *fSys, FMemCell cell)
{
   /* TODO: mutex_lock */
   fSys->memory[fSys->memoryTop ++] = cell;
   /* TODO: mutex unlock */

   return F_RC_OK;
}

RetCode fMemPutData(FSystem *fSys, FMemCell header, FMemCell *data, size_t size)
{
   if (fSys->memoryTop + size >= F_MEMORY_SIZE)
   {
      errno = E2BIG;
      return F_RC_ERROR;
   }

   fSys->memory[fSys->memoryTop ++] = header;
   memcpy(&fSys->memory[fSys->memoryTop], data, size);
   fSys->memoryTop += size;
   return F_RC_OK;
}
RetCode fMemSetData(FSystem *fSys, FIndex idx, FMemCell *data, size_t size)
{
   if (idx >= F_MEMORY_SIZE)
   {
      errno = E2BIG;
      return F_RC_ERROR;
   }

   memcpy(&fSys->memory[idx], data, size);
   return F_RC_OK;
}

/* Read memory without shifting memory pointer,
 * just set the instruction type, value (if any) 
 * and return the size of the instruction and its value */
FOffset fMemRead(FSystem *fSys, FIndex ptr, FValue *value, FMemType *type)
{
   if (fSys == NULL || value == NULL || type == NULL)
   {
      errno = EINVAL;
      return 0;
   }

   memset(value, 0, sizeof(FValue));

   *type = fSys->memory[ptr];

   switch (*type)
   {
      case F_MEM_INT:
         memcpy(&value->fInt, &fSys->memory[ptr + 1], sizeof(FInt));
         return sizeof(FInt) / sizeof(FMemCell) + 1;
      case F_MEM_FLOAT:
         memcpy(&value->fFloat, &fSys->memory[ptr + 1], sizeof(FFloat));
         return sizeof(FFloat) / sizeof(FMemCell) + 1;
      case F_MEM_NATIVE:
         memcpy(&value->fNative, &fSys->memory[ptr + 1], sizeof(FNative));
         return sizeof(FNative) / sizeof(FMemCell) + 1;
      case F_MEM_BLOCK:
         memcpy(&value->fOffset, &fSys->memory[ptr + 1], sizeof(FOffset));
         return sizeof(FOffset) / sizeof(FMemCell) + 1;
      default:
         return 1;
   }
}

/* read the next instruction and modify the memory pointer to the next instruction */
RetCode fMemReadNext(FSystem *fSys, FValue *value, FMemType *type)
{
   FOffset offset = fMemRead(fSys, fSys->execP, value, type);
   if (offset == 0)
      return F_RC_ERROR;

   fSys->execP += offset;

   return F_RC_OK;
}

/* get the type of the instruction by ptr address */
FMemType fMemGetType(FSystem *fSys, FIndex ptr)
{
   return fSys->memory[ptr];
}

FBool isInteger(char *word, FInt *val)
{
   int rc;

   if (index(word, '.') != NULL)
      return F_FALSE;

   if (word[0] == '0' && word[1] == 'x')
   {
      rc = sscanf(word, F_HEX64, val);
      return (rc == 1 ? F_TRUE : F_FALSE);
   }
   
   rc = sscanf(word, F_INT64, val);
   return (rc == 1 ? F_TRUE : F_FALSE);
}

FBool isFloat(char *word, FFloat *val)
{
   int rc = sscanf(word, "%lf", val);
   return (rc == 1 ? F_TRUE : F_FALSE);
}

/* compile single word, put to memory */
RetCode fCompileWord(FSystem *fSys, char *word)
{
   FIndex   s = F_NULL;    /* a symbol's address */
   FFloat   f = 0;         /* a float value */
   FInt     d = 0;         /* an integer */

   /* if it's a quoted symbol */
   /* find the ID or put a new symbol on a dictionary */
   if (word[0] == '\\')
   {
      /* TODO:!!! */
      s = fSymRegister(fSys, F_NULL, &word[1], F_MEM_UNDEFINED, NULL, NULL);
      if (s != F_NULL)
         fMemPutData(fSys, F_MEM_SYMBOL, (FMemCell*) &s, sizeof(FId));
   }

   /* if a string */
   else if (word[0] == '"')
   {
      /* TODO! */
   }

   /* if an integer */
   else if (isInteger(word, &d))
   {
      fMemPutData(fSys, F_MEM_INT, (FMemCell*) &d, sizeof(FInt));
   }

   /* if a float */
   else if (isFloat(word, &f))
   {
      fMemPutData(fSys, F_MEM_FLOAT, (FMemCell*) &f, sizeof(FFloat));
   }

   /* no words can contain []{}() as a part of the name, so we can check just one byte */
   /* block start */
   else if (word[0] == '[')
   {
      /* remember the starting address */
      FValue val;
      val.fIndex = fSys->memoryTop;
      fStackPush(fSys, val);

      /* push the dictionary size to forget local variables later */
      val.fIndex = fSys->retStackTop;
      fStackPush(fSys, val);

      FOffset blockSize = 0;
      F_MEM_PUT(fSys, F_MEM_BLOCK, &blockSize);
   }

   /* end of a block; returning instructions */
   else if (word[0] == ']')
   {
      FValue dictTop;
      FValue starter;

      /* return dictionary to previous state */
      if (fStackPop(fSys, &dictTop) != F_RC_OK || fStackPop(fSys, &starter) != F_RC_OK)
      {
         fLogErr("Incorrect stack state");
         errno = EINVAL;
         return F_RC_ERROR;
      }

      /* put the return instruction */
      fMemPut(fSys, F_MEM_RETURN);

      /* set the block size for '[' instruction */
      fMemSetData(fSys, starter.fIndex + 1, (FMemCell*)&fSys->memoryTop, sizeof(FIndex));

      /* revert dictionary state (forget local variables) */
      fSys->retStackTop = dictTop.fIndex;
   }

   else if (strcmp(word, "exec") == 0)
   {
      fMemPut(fSys, F_MEM_EXEC);
   }

   /* runtime symbol definition instruction */
   else if (strcmp(word, "def") == 0)
   {
      fMemPut(fSys, F_MEM_DEF);
   }

   /* a symbol */
   else
   {
      s = fSymGetByName(fSys, word);
      if (s != F_NULL)
         F_MEM_PUT(fSys, fSys->dictionary[s].type, &fSys->dictionary[s].value);
      else
      {
         fLogErr("unknown symbol");
         errno = ENOENT;
         return F_RC_ERROR;
      }
   }

   return F_RC_OK;
}

/* execute a single word from memory by current address */
RetCode fExecuteWord(FSystem *fSys)
{
   FValue   value = {0};
   FMemType type = F_MEM_UNDEFINED;
   FIndex   offset;
   RetCode  rc = F_RC_OK;

   /* read the instruction and move the execution pointer */
   offset = fMemRead(fSys, fSys->execP, &value, &type);
   if (offset == 0)
      return F_RC_ERROR;
   fSys->execP += offset;

   switch (type)
   {
      case F_MEM_INT:
      case F_MEM_FLOAT:
         fStackPush(fSys, value);
         break;

      case F_MEM_NATIVE:
         {
            rc = value.fNative(fSys);
            if (rc == F_RC_SKIP)
               return F_RC_OK;
            if (rc != F_RC_OK)
               return F_RC_ERROR;
            break;
         }

      case F_MEM_BLOCK:
         {
            /* block code address for future execution */
            FValue codeAddr;
            codeAddr.fIndex = fSys->execP - offset;
            fStackPush(fSys, codeAddr);

            /* jump out of the block */
            fSys->execP = value.fIndex;

            return F_RC_OK;
         }

      case F_MEM_RETURN:
         {
            FIndex addr;
            F_RC_CHECK( fRetDrop(fSys) ); /* drop the block address */
            F_RC_CHECK( fRetDrop(fSys) ); /* drop the dictionary address */

            if (fRetPop(fSys, &addr) != F_RC_OK)
            {
               fLogErr("unable to get return address from the return stack");
               return F_RC_ERROR;
            }

            fSys->execP = addr;
            return F_RC_OK;
         }

      case F_MEM_EXEC:
         {
            FValue val;
            if (fStackPop(fSys, &val) != F_RC_OK)
            {
               fLogErr("exec: no address given");
               return F_RC_ERROR;
            }

            return fExecuteBlock(fSys, val.fIndex);
         }

      case F_MEM_DEF:
         fNativeDef(fSys);
         return F_RC_OK;

      case F_MEM_UNDEFINED:
      case F_MEM_STOP:
         return F_RC_STOP;
      default:
         fLogOut("Unknown instruction during execution");
         return F_RC_ERROR;
         break;
   }

   return F_RC_OK;
}

RetCode fExecute(FSystem *fSys)
{
   RetCode rc = F_RC_OK;
   while ((rc = fExecuteWord(fSys)) == F_RC_OK && fSys->execP < fSys->memoryTop);
   return rc;
}

/* }}} */

/*********************************************************************************/
/* Main */
/* :main {{{ */

int main(int argc, char **argv)
{
   FSystem fSys;
   char *input = NULL;
   char wbuf[64 + 1] = {0};
   size_t bytesRead = 0;
   size_t r = 0;
   RetCode rc = F_RC_OK;

   fInit(&fSys);
   using_history();

   while ((input = readline("mf> ")) != NULL)
   {
      bytesRead = 0;
      fSys.memoryTop = 0;
      rc = F_RC_OK;

      while (rc == F_RC_OK && (r = fParseWord(&input[bytesRead], wbuf)) > 0 && bytesRead < 1024)
      {
         rc = fCompileWord(&fSys, wbuf);
         bytesRead += r;
      }
      fMemPut(&fSys, F_MEM_STOP);

      if (rc == F_RC_OK)
      {
         fSys.execP = 0;
         fExecute(&fSys);
      }

      add_history(input);
      free(input);
   }

   return 0;
}

/* }}} */
